home *** CD-ROM | disk | FTP | other *** search
/ Amiga Tools 5 / Amiga Tools 5.iso / tools / developer-tools / andere sprachen / perl5 / perl5.002 / lib / extutils / xsubpp < prev   
Encoding:
Text File  |  1996-02-12  |  28.3 KB  |  1,173 lines
  1. #!./miniperl
  2.  
  3. =head1 NAME
  4.  
  5. xsubpp - compiler to convert Perl XS code into C code
  6.  
  7. =head1 SYNOPSIS
  8.  
  9. B<xsubpp> [B<-v>] [B<-C++>] [B<-except>] [B<-s pattern>] [B<-prototypes>] [B<-noversioncheck>] [B<-typemap typemap>]... file.xs
  10.  
  11. =head1 DESCRIPTION
  12.  
  13. I<xsubpp> will compile XS code into C code by embedding the constructs
  14. necessary to let C functions manipulate Perl values and creates the glue
  15. necessary to let Perl access those functions.  The compiler uses typemaps to
  16. determine how to map C function parameters and variables to Perl values.
  17.  
  18. The compiler will search for typemap files called I<typemap>.  It will use
  19. the following search path to find default typemaps, with the rightmost
  20. typemap taking precedence.
  21.  
  22.     ../../../typemap:../../typemap:../typemap:typemap
  23.  
  24. =head1 OPTIONS
  25.  
  26. =over 5
  27.  
  28. =item B<-C++>
  29.  
  30. Adds ``extern "C"'' to the C code.
  31.  
  32.  
  33. =item B<-except>
  34.  
  35. Adds exception handling stubs to the C code.
  36.  
  37. =item B<-typemap typemap>
  38.  
  39. Indicates that a user-supplied typemap should take precedence over the
  40. default typemaps.  This option may be used multiple times, with the last
  41. typemap having the highest precedence.
  42.  
  43. =item B<-v>
  44.  
  45. Prints the I<xsubpp> version number to standard output, then exits.
  46.  
  47. =item B<-prototypes>
  48.  
  49. By default I<xsubpp> will not automatically generate prototype code for
  50. all xsubs. This flag will enable prototypes.
  51.  
  52. =item B<-noversioncheck>
  53.  
  54. Disables the run time test that determines if the object file (derived
  55. from the C<.xs> file) and the C<.pm> files have the same version
  56. number.
  57.  
  58. =back
  59.  
  60. =head1 ENVIRONMENT
  61.  
  62. No environment variables are used.
  63.  
  64. =head1 AUTHOR
  65.  
  66. Larry Wall
  67.  
  68. =head1 MODIFICATION HISTORY
  69.  
  70. See the file F<changes.pod>.
  71.  
  72. =head1 SEE ALSO
  73.  
  74. perl(1), perlxs(1), perlxstut(1), perlapi(1)
  75.  
  76. =cut
  77.  
  78. # Global Constants
  79. $XSUBPP_version = "1.933";
  80. require 5.002;
  81.  
  82. sub Q ;
  83.  
  84. $FH = 'File0000' ;
  85.  
  86. $usage = "Usage: xsubpp [-v] [-C++] [-except] [-prototypes] [-noversioncheck] [-s pattern] [-typemap typemap]... file.xs\n";
  87.  
  88. $proto_re = "[" . quotemeta('\$%&*@;') . "]" ;
  89.  
  90. $except = "";
  91. $WantPrototypes = -1 ;
  92. $WantVersionChk = 1 ;
  93. $ProtoUsed = 0 ;
  94. SWITCH: while (@ARGV and $ARGV[0] =~ /^-./) {
  95.     $flag = shift @ARGV;
  96.     $flag =~ s/^-// ;
  97.     $spat = shift,    next SWITCH    if $flag eq 's';
  98.     $cplusplus = 1,    next SWITCH    if $flag eq 'C++';
  99.     $WantPrototypes = 0, next SWITCH    if $flag eq 'noprototypes';
  100.     $WantPrototypes = 1, next SWITCH    if $flag eq 'prototypes';
  101.     $WantVersionChk = 0, next SWITCH    if $flag eq 'noversioncheck';
  102.     $WantVersionChk = 1, next SWITCH    if $flag eq 'versioncheck';
  103.     $except = " TRY",    next SWITCH    if $flag eq 'except';
  104.     push(@tm,shift),    next SWITCH    if $flag eq 'typemap';
  105.     (print "xsubpp version $XSUBPP_version\n"), exit      
  106.     if $flag eq 'v';
  107.     die $usage;
  108. }
  109. if ($WantPrototypes == -1)
  110.   { $WantPrototypes = 0}
  111. else
  112.   { $ProtoUsed = 1 }
  113.  
  114.  
  115. @ARGV == 1 or die $usage;
  116. ($dir, $filename) = $ARGV[0] =~ m#(.*)/(.*)#
  117.     or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)#
  118.     or ($dir, $filename) = ('.', $ARGV[0]);
  119. chdir($dir);
  120. # Check for VMS; Config.pm may not be installed yet, but this routine
  121. # is built into VMS perl
  122. if (defined(&VMS::Filespec::vmsify)) { $Is_VMS = 1; $pwd = $ENV{DEFAULT}; }
  123. else                                 { $Is_VMS = 0; chomp($pwd = `pwd`);   }
  124.  
  125. ++ $IncludedFiles{$ARGV[0]} ;
  126.  
  127. sub TrimWhitespace
  128. {
  129.     $_[0] =~ s/^\s+|\s+$//go ;
  130. }
  131.  
  132. sub TidyType
  133. {
  134.     local ($_) = @_ ;
  135.  
  136.     # rationalise any '*' by joining them into bunches and removing whitespace
  137.     s#\s*(\*+)\s*#$1#g;
  138.     s#(\*+)# $1 #g ;
  139.  
  140.     # change multiple whitespace into a single space
  141.     s/\s+/ /g ;
  142.     
  143.     # trim leading & trailing whitespace
  144.     TrimWhitespace($_) ;
  145.  
  146.     $_ ;
  147. }
  148.  
  149. $typemap = shift @ARGV;
  150. foreach $typemap (@tm) {
  151.     die "Can't find $typemap in $pwd\n" unless -r $typemap;
  152. }
  153. unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap
  154.                 ../../lib/ExtUtils/typemap ../../../typemap ../../typemap
  155.                 ../typemap typemap);
  156. foreach $typemap (@tm) {
  157.     next unless -e $typemap ;
  158.     # skip directories, binary files etc.
  159.     warn("Warning: ignoring non-text typemap file '$typemap'\n"), next 
  160.     unless -T $typemap ;
  161.     open(TYPEMAP, $typemap) 
  162.     or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
  163.     $mode = 'Typemap';
  164.     $junk = "" ;
  165.     $current = \$junk;
  166.     while (<TYPEMAP>) {
  167.     next if /^\s*#/;
  168.     if (/^INPUT\s*$/)   { $mode = 'Input';   $current = \$junk;  next; }
  169.     if (/^OUTPUT\s*$/)  { $mode = 'Output';  $current = \$junk;  next; }
  170.     if (/^TYPEMAP\s*$/) { $mode = 'Typemap'; $current = \$junk;  next; }
  171.     if ($mode eq 'Typemap') {
  172.         chomp;
  173.         my $line = $_ ;
  174.             TrimWhitespace($_) ;
  175.         # skip blank lines and comment lines
  176.         next if /^$/ or /^#/ ;
  177.         my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or
  178.         warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next;
  179.             $type = TidyType($type) ;
  180.         $type_kind{$type} = $kind ;
  181.             # prototype defaults to '$'
  182.             $proto = '$' unless $proto ;
  183.             warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n") 
  184.                 unless ValidProtoString($proto) ;
  185.             $proto_letter{$type} = C_string($proto) ;
  186.     }
  187.     elsif (/^\s/) {
  188.         $$current .= $_;
  189.     }
  190.     elsif ($mode eq 'Input') {
  191.         s/\s+$//;
  192.         $input_expr{$_} = '';
  193.         $current = \$input_expr{$_};
  194.     }
  195.     else {
  196.         s/\s+$//;
  197.         $output_expr{$_} = '';
  198.         $current = \$output_expr{$_};
  199.     }
  200.     }
  201.     close(TYPEMAP);
  202. }
  203.  
  204. foreach $key (keys %input_expr) {
  205.     $input_expr{$key} =~ s/\n+$//;
  206. }
  207.  
  208. $END = "!End!\n\n";        # "impossible" keyword (multiple newline)
  209.  
  210. # Match an XS keyword
  211. $BLOCK_re= '\s*(' . join('|', qw(
  212.     REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT 
  213.     CLEANUP ALIAS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE
  214.     )) . "|$END)\\s*:";
  215.  
  216. # Input:  ($_, @line) == unparsed input.
  217. # Output: ($_, @line) == (rest of line, following lines).
  218. # Return: the matched keyword if found, otherwise 0
  219. sub check_keyword {
  220.     $_ = shift(@line) while !/\S/ && @line;
  221.     s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
  222. }
  223.  
  224.  
  225. sub print_section {
  226.     $_ = shift(@line) while !/\S/ && @line;
  227.     for (;  defined($_) && !/^$BLOCK_re/o;  $_ = shift(@line)) {
  228.     print "$_\n";
  229.     }
  230. }
  231.  
  232. sub process_keyword($)
  233. {
  234.     my($pattern) = @_ ;
  235.     my $kwd ;
  236.  
  237.     &{"${kwd}_handler"}() 
  238.         while $kwd = check_keyword($pattern) ;
  239. }
  240.  
  241. sub CASE_handler {
  242.     blurt ("Error: `CASE:' after unconditional `CASE:'")
  243.     if $condnum && $cond eq '';
  244.     $cond = $_;
  245.     TrimWhitespace($cond);
  246.     print "   ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
  247.     $_ = '' ;
  248. }
  249.  
  250. sub INPUT_handler {
  251.     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
  252.     last if /^\s*NOT_IMPLEMENTED_YET/;
  253.     next unless /\S/;    # skip blank lines 
  254.  
  255.     TrimWhitespace($_) ;
  256.     my $line = $_ ;
  257.  
  258.     # remove trailing semicolon if no initialisation
  259.     s/\s*;$//g unless /=/ ;
  260.  
  261.     # check for optional initialisation code
  262.     my $var_init = '' ;
  263.     $var_init = $1 if s/\s*(=.*)$//s ;
  264.     $var_init =~ s/"/\\"/g;
  265.  
  266.     s/\s+/ /g;
  267.     my ($var_type, $var_addr, $var_name) = /^(.*?[^& ]) *(\&?) *\b(\w+)$/s
  268.         or blurt("Error: invalid argument declaration '$line'"), next;
  269.  
  270.     # Check for duplicate definitions
  271.     blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
  272.         if $arg_list{$var_name} ++  ;
  273.  
  274.     $thisdone |= $var_name eq "THIS";
  275.     $retvaldone |= $var_name eq "RETVAL";
  276.     $var_types{$var_name} = $var_type;
  277.     print "\t" . &map_type($var_type);
  278.     $var_num = $args_match{$var_name};
  279.  
  280.         $proto_arg[$var_num] = ProtoString($var_type) 
  281.         if $var_num ;
  282.     if ($var_addr) {
  283.         $var_addr{$var_name} = 1;
  284.         $func_args =~ s/\b($var_name)\b/&$1/;
  285.     }
  286.     if ($var_init =~ /^=\s*NO_INIT\s*;?\s*$/) {
  287.         print "\t$var_name;\n";
  288.     } elsif ($var_init =~ /\S/) {
  289.         &output_init($var_type, $var_num, "$var_name $var_init");
  290.     } elsif ($var_num) {
  291.         # generate initialization code
  292.         &generate_init($var_type, $var_num, $var_name);
  293.     } else {
  294.         print ";\n";
  295.     }
  296.     }
  297. }
  298.  
  299. sub OUTPUT_handler {
  300.     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
  301.     next unless /\S/;
  302.     my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ;
  303.     blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
  304.         if $outargs{$outarg} ++ ;
  305.     if (!$gotRETVAL and $outarg eq 'RETVAL') {
  306.         # deal with RETVAL last
  307.         $RETVAL_code = $outcode ;
  308.         $gotRETVAL = 1 ;
  309.         next ;
  310.     }
  311.     blurt ("Error: OUTPUT $outarg not an argument"), next
  312.         unless defined($args_match{$outarg});
  313.     blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
  314.         unless defined $var_types{$outarg} ;
  315.     if ($outcode) {
  316.         print "\t$outcode\n";
  317.     } else {
  318.         $var_num = $args_match{$outarg};
  319.         &generate_output($var_types{$outarg}, $var_num, $outarg); 
  320.     }
  321.     }
  322. }
  323.  
  324. sub CLEANUP_handler() { print_section() } 
  325. sub PREINIT_handler() { print_section() } 
  326. sub INIT_handler()    { print_section() } 
  327.  
  328. sub GetAliases
  329. {
  330.     my ($line) = @_ ;
  331.     my ($orig) = $line ;
  332.     my ($alias) ;
  333.     my ($value) ;
  334.  
  335.     # Parse alias definitions
  336.     # format is
  337.     #    alias = value alias = value ...
  338.  
  339.     while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
  340.         $alias = $1 ;
  341.         $orig_alias = $alias ;
  342.         $value = $2 ;
  343.  
  344.         # check for optional package definition in the alias
  345.     $alias = $Packprefix . $alias if $alias !~ /::/ ;
  346.         
  347.         # check for duplicate alias name & duplicate value
  348.     Warn("Warning: Ignoring duplicate alias '$orig_alias'")
  349.         if defined $XsubAliases{$pname}{$alias} ;
  350.  
  351.         Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$pname}{$value}' have identical values")
  352.         if $XsubAliasValues{$pname}{$value} ;
  353.  
  354.         $XsubAliases{$pname}{$alias} = $value ;
  355.         $XsubAliasValues{$pname}{$value} = $orig_alias ;
  356.     }
  357.  
  358.     blurt("Error: Cannot parse ALIAS definitions from '$orig'")
  359.         if $line ;
  360. }
  361.  
  362. sub ALIAS_handler ()
  363. {
  364.     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
  365.     next unless /\S/;
  366.     TrimWhitespace($_) ;
  367.         GetAliases($_) if $_ ;
  368.     }
  369. }
  370.  
  371. sub REQUIRE_handler ()
  372. {
  373.     # the rest of the current line should contain a version number
  374.     my ($Ver) = $_ ;
  375.  
  376.     TrimWhitespace($Ver) ;
  377.  
  378.     death ("Error: REQUIRE expects a version number")
  379.     unless $Ver ;
  380.  
  381.     # check that the version number is of the form n.n
  382.     death ("Error: REQUIRE: expected a number, got '$Ver'")
  383.     unless $Ver =~ /^\d+(\.\d*)?/ ;
  384.  
  385.     death ("Error: xsubpp $Ver (or better) required--this is only $XSUBPP_version.")
  386.         unless $XSUBPP_version >= $Ver ; 
  387. }
  388.  
  389. sub VERSIONCHECK_handler ()
  390. {
  391.     # the rest of the current line should contain either ENABLE or
  392.     # DISABLE
  393.  
  394.     TrimWhitespace($_) ;
  395.  
  396.     # check for ENABLE/DISABLE
  397.     death ("Error: VERSIONCHECK: ENABLE/DISABLE")
  398.         unless /^(ENABLE|DISABLE)/i ;
  399.  
  400.     $WantVersionChk = 1 if $1 eq 'ENABLE' ;
  401.     $WantVersionChk = 0 if $1 eq 'DISABLE' ;
  402.  
  403. }
  404.  
  405. sub PROTOTYPE_handler ()
  406. {
  407.     my $specified ;
  408.  
  409.     death("Error: Only 1 PROTOTYPE definition allowed per xsub") 
  410.         if $proto_in_this_xsub ++ ;
  411.  
  412.     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
  413.     next unless /\S/;
  414.     $specified = 1 ;
  415.     TrimWhitespace($_) ;
  416.         if ($_ eq 'DISABLE') {
  417.        $ProtoThisXSUB = 0 
  418.         }
  419.         elsif ($_ eq 'ENABLE') {
  420.        $ProtoThisXSUB = 1 
  421.         }
  422.         else {
  423.             # remove any whitespace
  424.             s/\s+//g ;
  425.             death("Error: Invalid prototype '$_'")
  426.                 unless ValidProtoString($_) ;
  427.             $ProtoThisXSUB = C_string($_) ;
  428.         }
  429.     }
  430.  
  431.     # If no prototype specified, then assume empty prototype ""
  432.     $ProtoThisXSUB = 2 unless $specified ;
  433.  
  434.     $ProtoUsed = 1 ;
  435.  
  436. }
  437.  
  438. sub PROTOTYPES_handler ()
  439. {
  440.     # the rest of the current line should contain either ENABLE or
  441.     # DISABLE 
  442.  
  443.     TrimWhitespace($_) ;
  444.  
  445.     # check for ENABLE/DISABLE
  446.     death ("Error: PROTOTYPES: ENABLE/DISABLE")
  447.         unless /^(ENABLE|DISABLE)/i ;
  448.  
  449.     $WantPrototypes = 1 if $1 eq 'ENABLE' ;
  450.     $WantPrototypes = 0 if $1 eq 'DISABLE' ;
  451.     $ProtoUsed = 1 ;
  452.  
  453. }
  454.  
  455. sub INCLUDE_handler ()
  456. {
  457.     # the rest of the current line should contain a valid filename
  458.  
  459.     TrimWhitespace($_) ;
  460.  
  461.     death("INCLUDE: filename missing")
  462.         unless $_ ;
  463.  
  464.     death("INCLUDE: output pipe is illegal")
  465.         if /^\s*\|/ ;
  466.  
  467.     # simple minded recursion detector
  468.     death("INCLUDE loop detected")
  469.         if $IncludedFiles{$_} ;
  470.  
  471.     ++ $IncludedFiles{$_} unless /\|\s*$/ ;
  472.  
  473.     # Save the current file context.
  474.     push(@FileStack, {
  475.         LastLine        => $lastline,
  476.         LastLineNo      => $lastline_no,
  477.         Line            => \@line,
  478.         LineNo          => \@line_no,
  479.         Filename        => $filename,
  480.         Handle          => $FH,
  481.         }) ;
  482.  
  483.     ++ $FH ;
  484.  
  485.     # open the new file
  486.     open ($FH, "$_") or death("Cannot open '$_': $!") ;
  487.  
  488.     print Q<<"EOF" ;
  489. #
  490. #/* INCLUDE:  Including '$_' from '$filename' */
  491. #
  492. EOF
  493.  
  494.     $filename = $_ ;
  495.  
  496.     # Prime the pump by reading the first 
  497.     # non-blank line
  498.  
  499.     # skip leading blank lines
  500.     while (<$FH>) {
  501.         last unless /^\s*$/ ;
  502.     }
  503.  
  504.     $lastline = $_ ;
  505.     $lastline_no = $. ;
  506.  
  507. }
  508.  
  509. sub PopFile()
  510. {
  511.     return 0 unless @FileStack ;
  512.  
  513.     my $data     = pop @FileStack ;
  514.     my $ThisFile = $filename ;
  515.     my $isPipe   = ($filename =~ /\|\s*$/) ;
  516.  
  517.     -- $IncludedFiles{$filename}
  518.         unless $isPipe ;
  519.  
  520.     close $FH ;
  521.  
  522.     $FH         = $data->{Handle} ;
  523.     $filename   = $data->{Filename} ;
  524.     $lastline   = $data->{LastLine} ;
  525.     $lastline_no = $data->{LastLineNo} ;
  526.     @line       = @{ $data->{Line} } ;
  527.     @line_no    = @{ $data->{LineNo} } ;
  528.  
  529.     if ($isPipe and $? ) {
  530.         -- $lastline_no ;
  531.         print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n"  ;
  532.         exit 1 ;
  533.     }
  534.  
  535.     print Q<<"EOF" ;
  536. #
  537. #/* INCLUDE: Returning to '$filename' from '$ThisFile' */
  538. #
  539. EOF
  540.  
  541.     return 1 ;
  542. }
  543.  
  544. sub ValidProtoString ($)
  545. {
  546.     my($string) = @_ ;
  547.  
  548.     if ( $string =~ /^$proto_re+$/ ) {
  549.         return $string ;
  550.     }
  551.  
  552.     return 0 ;
  553. }
  554.  
  555. sub C_string ($)
  556. {
  557.     my($string) = @_ ;
  558.  
  559.     $string =~ s[\\][\\\\]g ;
  560.     $string ;
  561. }
  562.  
  563. sub ProtoString ($)
  564. {
  565.     my ($type) = @_ ;
  566.  
  567.     $proto_letter{$type} or '$' ;
  568. }
  569.  
  570. sub check_cpp {
  571.     my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
  572.     if (@cpp) {
  573.     my ($cpp, $cpplevel);
  574.     for $cpp (@cpp) {
  575.         if ($cpp =~ /^\#\s*if/) {
  576.         $cpplevel++;
  577.         } elsif (!$cpplevel) {
  578.         Warn("Warning: #else/elif/endif without #if in this function");
  579.         return;
  580.         } elsif ($cpp =~ /^\#\s*endif/) {
  581.         $cpplevel--;
  582.         }
  583.     }
  584.     Warn("Warning: #if without #endif in this function") if $cpplevel;
  585.     }
  586. }
  587.  
  588.  
  589. sub Q {
  590.     my($text) = @_;
  591.     $text =~ s/^#//gm;
  592.     $text =~ s/\[\[/{/g;
  593.     $text =~ s/\]\]/}/g;
  594.     $text;
  595. }
  596.  
  597. open($FH, $filename) or die "cannot open $filename: $!\n";
  598.  
  599. # Identify the version of xsubpp used
  600. print <<EOM ;
  601. /*
  602.  * This file was generated automatically by xsubpp version $XSUBPP_version from the 
  603.  * contents of $filename. Don't edit this file, edit $filename instead.
  604.  *
  605.  *    ANY CHANGES MADE HERE WILL BE LOST! 
  606.  *
  607.  */
  608.  
  609. EOM
  610.  
  611.  
  612. while (<$FH>) {
  613.     last if ($Module, $Package, $Prefix) =
  614.     /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
  615.     print $_;
  616. }
  617. &Exit unless defined $_;
  618.  
  619. $lastline    = $_;
  620. $lastline_no = $.;
  621.  
  622.  
  623. # Read next xsub into @line from ($lastline, <$FH>).
  624. sub fetch_para {
  625.     # parse paragraph
  626.     @line = ();
  627.     @line_no = () ;
  628.     if (! defined $lastline) {
  629.         return 1 if PopFile() ;
  630.         return 0 ;
  631.     }
  632.  
  633.     if ($lastline =~
  634.     /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
  635.     $Module = $1;
  636.     $Package = defined($2) ? $2 : '';    # keep -w happy
  637.     $Prefix  = defined($3) ? $3 : '';    # keep -w happy
  638.     ($Module_cname = $Module) =~ s/\W/_/g;
  639.     ($Packid = $Package) =~ tr/:/_/;
  640.     $Packprefix = $Package;
  641.     $Packprefix .= "::" if $Packprefix ne "";
  642.     $lastline = "";
  643.     }
  644.  
  645.     for(;;) {
  646.     if ($lastline !~ /^\s*#/ ||
  647.         $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|else|elif|endif|define|undef|pragma)\b|include\s*["<].*[>"])/) {
  648.         last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
  649.         push(@line, $lastline);
  650.         push(@line_no, $lastline_no) ;
  651.     }
  652.  
  653.     # Read next line and continuation lines
  654.     last unless defined($lastline = <$FH>);
  655.     $lastline_no = $.;
  656.     my $tmp_line;
  657.     $lastline .= $tmp_line
  658.         while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>));
  659.         
  660.     chomp $lastline;
  661.     $lastline =~ s/^\s+$//;
  662.     }
  663.     pop(@line), pop(@line_no) while @line && $line[-1] eq "";
  664.     1;
  665. }
  666.  
  667. PARAGRAPH:
  668. while (fetch_para()) {
  669.     # Print initial preprocessor statements and blank lines
  670.     print shift(@line), "\n"
  671.     while @line && $line[0] !~ /^[^\#]/;
  672.  
  673.     next PARAGRAPH unless @line;
  674.  
  675.     death ("Code is not inside a function")
  676.     if $line[0] =~ /^\s/;
  677.  
  678.     # initialize info arrays
  679.     undef(%args_match);
  680.     undef(%var_types);
  681.     undef(%var_addr);
  682.     undef(%defaults);
  683.     undef($class);
  684.     undef($static);
  685.     undef($elipsis);
  686.     undef($wantRETVAL) ;
  687.     undef(%arg_list) ;
  688.     undef(@proto_arg) ;
  689.     undef($proto_in_this_xsub) ;
  690.     $ProtoThisXSUB = $WantPrototypes ;
  691.  
  692.     $_ = shift(@line);
  693.     while ($kwd = check_keyword("REQUIRE|PROTOTYPES|VERSIONCHECK|INCLUDE")) {
  694.         &{"${kwd}_handler"}() ;
  695.         next PARAGRAPH unless @line ;
  696.         $_ = shift(@line);
  697.     }
  698.  
  699.     if (check_keyword("BOOT")) {
  700.     &check_cpp;
  701.         push (@BootCode, $_, @line, "") ;
  702.         next PARAGRAPH ;
  703.     }
  704.  
  705.  
  706.     # extract return type, function name and arguments
  707.     my($ret_type) = TidyType($_);
  708.  
  709.     # a function definition needs at least 2 lines
  710.     blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
  711.     unless @line ;
  712.  
  713.     $static = 1 if $ret_type =~ s/^static\s+//;
  714.  
  715.     $func_header = shift(@line);
  716.     blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
  717.     unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*$/s;
  718.  
  719.     ($class, $func_name, $orig_args) =  ($1, $2, $3) ;
  720.     ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
  721.  
  722.     # Check for duplicate function definition
  723.     if (defined $Func_name{"${Packid}_$func_name"} ) {
  724.        Warn("Warning: duplicate function definition '$func_name' detected") 
  725.     }
  726.     else {
  727.         push(@Func_name, "${Packid}_$func_name");
  728.         push(@Func_pname, $pname);
  729.     }
  730.     $Func_name{"${Packid}_$func_name"} ++ ;
  731.  
  732.     @args = split(/\s*,\s*/, $orig_args);
  733.     if (defined($class)) {
  734.     my $arg0 = ((defined($static) or $func_name =~ /^new/) ? "CLASS" : "THIS");
  735.     unshift(@args, $arg0);
  736.     ($orig_args = "$arg0, $orig_args") =~ s/^$arg0, $/$arg0/;
  737.     }
  738.     $orig_args =~ s/"/\\"/g;
  739.     $min_args = $num_args = @args;
  740.     foreach $i (0..$num_args-1) {
  741.         if ($args[$i] =~ s/\.\.\.//) {
  742.             $elipsis = 1;
  743.             $min_args--;
  744.             if ($args[$i] eq '' && $i == $num_args - 1) {
  745.             pop(@args);
  746.             last;
  747.             }
  748.         }
  749.         if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) {
  750.             $min_args--;
  751.             $args[$i] = $1;
  752.             $defaults{$args[$i]} = $2;
  753.             $defaults{$args[$i]} =~ s/"/\\"/g;
  754.         }
  755.         $proto_arg[$i+1] = '$' ;
  756.     }
  757.     if (defined($class)) {
  758.         $func_args = join(", ", @args[1..$#args]);
  759.     } else {
  760.         $func_args = join(", ", @args);
  761.     }
  762.     @args_match{@args} = 1..@args;
  763.  
  764.     $PPCODE = grep(/^\s*PPCODE\s*:/, @line);
  765.     $ALIAS  = grep(/^\s*ALIAS\s*:/,  @line);
  766.  
  767.     # print function header
  768.     print Q<<"EOF";
  769. #XS(XS_${Packid}_$func_name)
  770. #[[
  771. #    dXSARGS;
  772. EOF
  773.     print Q<<"EOF" if $ALIAS ;
  774. #    dXSI32;
  775. EOF
  776.     if ($elipsis) {
  777.     $cond = ($min_args ? qq(items < $min_args) : 0);
  778.     }
  779.     elsif ($min_args == $num_args) {
  780.     $cond = qq(items != $min_args);
  781.     }
  782.     else {
  783.     $cond = qq(items < $min_args || items > $num_args);
  784.     }
  785.  
  786.     print Q<<"EOF" if $except;
  787. #    char errbuf[1024];
  788. #    *errbuf = '\0';
  789. EOF
  790.  
  791.     if ($ALIAS) 
  792.       { print Q<<"EOF" if $cond }
  793. #    if ($cond)
  794. #       croak("Usage: %s($orig_args)", GvNAME(CvGV(cv)));
  795. EOF
  796.     else 
  797.       { print Q<<"EOF" if $cond }
  798. #    if ($cond)
  799. #    croak("Usage: $pname($orig_args)");
  800. EOF
  801.  
  802.     print Q<<"EOF" if $PPCODE;
  803. #    SP -= items;
  804. EOF
  805.  
  806.     # Now do a block of some sort.
  807.  
  808.     $condnum = 0;
  809.     $cond = '';            # last CASE: condidional
  810.     push(@line, "$END:");
  811.     push(@line_no, $line_no[-1]);
  812.     $_ = '';
  813.     &check_cpp;
  814.     while (@line) {
  815.     &CASE_handler if check_keyword("CASE");
  816.     print Q<<"EOF";
  817. #   $except [[
  818. EOF
  819.  
  820.     # do initialization of input variables
  821.     $thisdone = 0;
  822.     $retvaldone = 0;
  823.     $deferred = "";
  824.     %arg_list = () ;
  825.         $gotRETVAL = 0;
  826.  
  827.     INPUT_handler() ;
  828.     process_keyword("INPUT|PREINIT|ALIAS|PROTOTYPE") ;
  829.  
  830.     if (!$thisdone && defined($class)) {
  831.         if (defined($static) or $func_name =~ /^new/) {
  832.         print "\tchar *";
  833.         $var_types{"CLASS"} = "char *";
  834.         &generate_init("char *", 1, "CLASS");
  835.         }
  836.         else {
  837.         print "\t$class *";
  838.         $var_types{"THIS"} = "$class *";
  839.         &generate_init("$class *", 1, "THIS");
  840.         }
  841.     }
  842.  
  843.     # do code
  844.     if (/^\s*NOT_IMPLEMENTED_YET/) {
  845.         print "\n\tcroak(\"$pname: not implemented yet\");\n";
  846.         $_ = '' ;
  847.     } else {
  848.         if ($ret_type ne "void") {
  849.             print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
  850.                 if !$retvaldone;
  851.             $args_match{"RETVAL"} = 0;
  852.             $var_types{"RETVAL"} = $ret_type;
  853.         }
  854.         print $deferred;
  855.                 process_keyword("INIT|ALIAS|PROTOTYPE") ;
  856.  
  857.         if (check_keyword("PPCODE")) {
  858.             print_section();
  859.             death ("PPCODE must be last thing") if @line;
  860.             print "\tPUTBACK;\n\treturn;\n";
  861.         } elsif (check_keyword("CODE")) {
  862.             print_section() ;
  863.         } elsif (defined($class) and $func_name eq "DESTROY") {
  864.             print "\n\t";
  865.             print "delete THIS;\n";
  866.         } else {
  867.             print "\n\t";
  868.             if ($ret_type ne "void") {
  869.                 print "RETVAL = ";
  870.                 $wantRETVAL = 1;
  871.             }
  872.             if (defined($static)) {
  873.                 if ($func_name =~ /^new/) {
  874.                 $func_name = "$class";
  875.                 } else {
  876.                 print "${class}::";
  877.                 }
  878.             } elsif (defined($class)) {
  879.                 if ($func_name =~ /^new/) {
  880.                 $func_name .= " $class";
  881.                 } else {
  882.                 print "THIS->";
  883.                 }
  884.             }
  885.             $func_name =~ s/^($spat)//
  886.                 if defined($spat);
  887.             print "$func_name($func_args);\n";
  888.         }
  889.     }
  890.  
  891.     # do output variables
  892.     $gotRETVAL = 0;
  893.     undef $RETVAL_code ;
  894.     undef %outargs ;
  895.         process_keyword("OUTPUT|ALIAS|PROTOTYPE"); 
  896.  
  897.     # all OUTPUT done, so now push the return value on the stack
  898.     if ($gotRETVAL && $RETVAL_code) {
  899.         print "\t$RETVAL_code\n";
  900.     } elsif ($gotRETVAL || $wantRETVAL) {
  901.         &generate_output($ret_type, 0, 'RETVAL');
  902.     }
  903.  
  904.     # do cleanup
  905.     process_keyword("CLEANUP|ALIAS|PROTOTYPE") ;
  906.  
  907.     # print function trailer
  908.     print Q<<EOF;
  909. #    ]]
  910. EOF
  911.     print Q<<EOF if $except;
  912. #    BEGHANDLERS
  913. #    CATCHALL
  914. #    sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
  915. #    ENDHANDLERS
  916. EOF
  917.     if (check_keyword("CASE")) {
  918.         blurt ("Error: No `CASE:' at top of function")
  919.         unless $condnum;
  920.         $_ = "CASE: $_";    # Restore CASE: label
  921.         next;
  922.     }
  923.     last if $_ eq "$END:";
  924.     death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function");
  925.     }
  926.  
  927.     print Q<<EOF if $except;
  928. #    if (errbuf[0])
  929. #    croak(errbuf);
  930. EOF
  931.  
  932.     print Q<<EOF unless $PPCODE;
  933. #    XSRETURN(1);
  934. EOF
  935.  
  936.     print Q<<EOF;
  937. #]]
  938. #
  939. EOF
  940.  
  941.     # Build the prototype string for the xsub
  942.     if ($ProtoThisXSUB) {
  943.         if ($ProtoThisXSUB == 2) {
  944.             # User has specified empty prototype
  945.             $ProtoXSUB{$pname} = '""'
  946.         }
  947.         elsif ($ProtoThisXSUB != 1) {
  948.             # User has specified a prototype
  949.             $ProtoXSUB{$pname} = '"' . $ProtoThisXSUB . '"'
  950.         }
  951.         else {
  952.         my $s = ';';
  953.             if ($min_args < $num_args)  {
  954.                 $s = ''; 
  955.         $proto_arg[$min_args] .= ";" ;
  956.         }
  957.             push @proto_arg, "${s}@" 
  958.                 if $elipsis ;
  959.     
  960.             $ProtoXSUB{$pname} = '"' . join ("", @proto_arg) . '"' 
  961.         }
  962.     }
  963.  
  964. }
  965.  
  966. # print initialization routine
  967. print Q<<"EOF";
  968. ##ifdef __cplusplus
  969. #extern "C"
  970. ##endif
  971. #XS(boot_$Module_cname)
  972. #[[
  973. #    dXSARGS;
  974. #    char* file = __FILE__;
  975. #
  976. EOF
  977.  
  978. print Q<<"EOF" if $WantVersionChk ;
  979. #    XS_VERSION_BOOTCHECK ;
  980. #
  981. EOF
  982.  
  983. print Q<<"EOF" if defined %XsubAliases ;
  984. #    {
  985. #        CV * cv ;
  986. #
  987. EOF
  988.  
  989. for (@Func_name) {
  990.     $pname = shift(@Func_pname);
  991.     my $newXS = "newXS" ;
  992.     my $proto = "" ;
  993.  
  994.     if ($ProtoXSUB{$pname}) {
  995.         $newXS = "newXSproto" ;
  996.         $proto = ", $ProtoXSUB{$pname}" ;
  997.     }
  998.  
  999.     if ($XsubAliases{$pname}) {
  1000.         $XsubAliases{$pname}{$pname} = 0 
  1001.         unless defined $XsubAliases{$pname}{$pname} ;
  1002.         while ( ($name, $value) = each %{$XsubAliases{$pname}}) {
  1003.             print Q<<"EOF" ;
  1004. #        cv = newXS(\"$name\", XS_$_, file);
  1005. #        XSANY.any_i32 = $value ;
  1006. EOF
  1007.             print Q<<"EOF" if $proto ;
  1008. #        sv_setpv((SV*)cv, $ProtoXSUB{$pname}) ;
  1009. EOF
  1010.         }
  1011.     }
  1012.     else {
  1013.         print "        ${newXS}(\"$pname\", XS_$_, file$proto);\n";
  1014.     }
  1015. }
  1016.  
  1017. print Q<<"EOF" if defined %XsubAliases ;
  1018. #    }
  1019. EOF
  1020.  
  1021. if (@BootCode)
  1022. {
  1023.     print "\n    /* Initialisation Section */\n" ;
  1024.     print grep (s/$/\n/, @BootCode) ;
  1025.     print "\n    /* End of Initialisation Section */\n\n" ;
  1026. }
  1027.  
  1028. print Q<<"EOF";;
  1029. #    ST(0) = &sv_yes;
  1030. #    XSRETURN(1);
  1031. #]]
  1032. EOF
  1033.  
  1034. warn("Please specify prototyping behavior for $filename (see perlxs manual)\n") 
  1035.     unless $ProtoUsed ;
  1036. &Exit;
  1037.  
  1038.  
  1039. sub output_init {
  1040.     local($type, $num, $init) = @_;
  1041.     local($arg) = "ST(" . ($num - 1) . ")";
  1042.  
  1043.     eval qq/print " $init\\\n"/;
  1044. }
  1045.  
  1046. sub Warn
  1047. {
  1048.     # work out the line number
  1049.     my $line_no = $line_no[@line_no - @line -1] ;
  1050.  
  1051.     print STDERR "@_ in $filename, line $line_no\n" ;
  1052. }
  1053.  
  1054. sub blurt 
  1055. { 
  1056.     Warn @_ ;
  1057.     $errors ++ 
  1058. }
  1059.  
  1060. sub death
  1061. {
  1062.     Warn @_ ;
  1063.     exit 1 ;
  1064. }
  1065.  
  1066. sub generate_init {
  1067.     local($type, $num, $var) = @_;
  1068.     local($arg) = "ST(" . ($num - 1) . ")";
  1069.     local($argoff) = $num - 1;
  1070.     local($ntype);
  1071.     local($tk);
  1072.  
  1073.     $type = TidyType($type) ;
  1074.     blurt("Error: '$type' not in typemap"), return 
  1075.     unless defined($type_kind{$type});
  1076.  
  1077.     ($ntype = $type) =~ s/\s*\*/Ptr/g;
  1078.     ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
  1079.     $tk = $type_kind{$type};
  1080.     $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
  1081.     $type =~ tr/:/_/;
  1082.     blurt("Error: No INPUT definition for type '$type' found"), return
  1083.         unless defined $input_expr{$tk} ;
  1084.     $expr = $input_expr{$tk};
  1085.     if ($expr =~ /DO_ARRAY_ELEM/) {
  1086.         blurt("Error: '$subtype' not in typemap"), return 
  1087.         unless defined($type_kind{$subtype});
  1088.         blurt("Error: No INPUT definition for type '$subtype' found"), return
  1089.             unless defined $input_expr{$type_kind{$subtype}} ;
  1090.     $subexpr = $input_expr{$type_kind{$subtype}};
  1091.     $subexpr =~ s/ntype/subtype/g;
  1092.     $subexpr =~ s/\$arg/ST(ix_$var)/g;
  1093.     $subexpr =~ s/\n\t/\n\t\t/g;
  1094.     $subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g;
  1095.     $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
  1096.     $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
  1097.     }
  1098.     if (defined($defaults{$var})) {
  1099.         $expr =~ s/(\t+)/$1    /g;
  1100.         $expr =~ s/        /\t/g;
  1101.         eval qq/print "\\t$var;\\n"/;
  1102.         $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t    $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
  1103.     } elsif ($expr !~ /^\t\$var =/) {
  1104.         eval qq/print "\\t$var;\\n"/;
  1105.         $deferred .= eval qq/"\\n$expr;\\n"/;
  1106.     } else {
  1107.         eval qq/print "$expr;\\n"/;
  1108.     }
  1109. }
  1110.  
  1111. sub generate_output {
  1112.     local($type, $num, $var) = @_;
  1113.     local($arg) = "ST(" . ($num - ($num != 0)) . ")";
  1114.     local($argoff) = $num - 1;
  1115.     local($ntype);
  1116.  
  1117.     $type = TidyType($type) ;
  1118.     if ($type =~ /^array\(([^,]*),(.*)\)/) {
  1119.         print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
  1120.     } else {
  1121.         blurt("Error: '$type' not in typemap"), return
  1122.         unless defined($type_kind{$type});
  1123.             blurt("Error: No OUTPUT definition for type '$type' found"), return
  1124.                 unless defined $output_expr{$type_kind{$type}} ;
  1125.         ($ntype = $type) =~ s/\s*\*/Ptr/g;
  1126.         $ntype =~ s/\(\)//g;
  1127.         ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
  1128.         $expr = $output_expr{$type_kind{$type}};
  1129.         if ($expr =~ /DO_ARRAY_ELEM/) {
  1130.             blurt("Error: '$subtype' not in typemap"), return
  1131.             unless defined($type_kind{$subtype});
  1132.                 blurt("Error: No OUTPUT definition for type '$subtype' found"), return
  1133.                     unless defined $output_expr{$type_kind{$subtype}} ;
  1134.         $subexpr = $output_expr{$type_kind{$subtype}};
  1135.         $subexpr =~ s/ntype/subtype/g;
  1136.         $subexpr =~ s/\$arg/ST(ix_$var)/g;
  1137.         $subexpr =~ s/\$var/${var}[ix_$var]/g;
  1138.         $subexpr =~ s/\n\t/\n\t\t/g;
  1139.         $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
  1140.         eval "print qq\a$expr\a";
  1141.         }
  1142.         elsif ($var eq 'RETVAL') {
  1143.         if ($expr =~ /^\t\$arg = /) {
  1144.             eval "print qq\a$expr\a";
  1145.             print "\tsv_2mortal(ST(0));\n";
  1146.         }
  1147.         else {
  1148.             print "\tST(0) = sv_newmortal();\n";
  1149.             eval "print qq\a$expr\a";
  1150.         }
  1151.         }
  1152.         elsif ($arg =~ /^ST\(\d+\)$/) {
  1153.         eval "print qq\a$expr\a";
  1154.         }
  1155.     }
  1156. }
  1157.  
  1158. sub map_type {
  1159.     my($type) = @_;
  1160.  
  1161.     $type =~ tr/:/_/;
  1162.     $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
  1163.     $type;
  1164. }
  1165.  
  1166.  
  1167. sub Exit {
  1168. # If this is VMS, the exit status has meaning to the shell, so we
  1169. # use a predictable value (SS$_Normal or SS$_Abort) rather than an
  1170. # arbitrary number.
  1171.     exit ($Is_VMS ? ($errors ? 44 : 1) : $errors) ;
  1172. }
  1173.